home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / resource.l < prev    next >
Lisp/Scheme  |  1988-09-12  |  24KB  |  629 lines
  1. ;;; -*- Mode:Common-Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3. ;; RESOURCE - Lisp version of XLIB's Xrm resource manager
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. (in-package 'xlib :use '(lisp))
  22.  
  23. (export '(resource-database
  24.        resource-database-timestamp
  25.        make-resource-database
  26.        resource-key
  27.        get-resource
  28.        get-search-table
  29.        get-search-resource
  30.        add-resource
  31.        delete-resource 
  32.        map-resource 
  33.        merge-resources
  34.        read-resources
  35.        write-resources
  36.        wm-resources
  37.        set-wm-resources))
  38.  
  39. #+clue ;; for CLUE only
  40. (defparameter *resource-subclassp* nil
  41.   "When non-nil and no match found, search superclasses.")
  42.  
  43. ;; The C version of this uses a 64 entry hash table at each entry.
  44. ;; Small hash tables loose in Lisp, so we do linear searches on lists.
  45.  
  46. ;; This code uses resource-database-NAME for resource lookup, and 
  47. ;; resource-database-STRING when reading/writing resources.  This
  48. ;; is to enable us to upcase and intern the string for fast resource
  49. ;; lookup EQ tests while maintaing the original string for 
  50. ;; write-resources [it should be possible to read a upper/lower
  51. ;; case resource file, modify it and write it out correctly]
  52.  
  53. (defstruct (resource-database (:copier nil) (:print-function print-resource)
  54.                   (:constructor make-resource-database-internal)
  55.                   #+explorer (:callable-constructors nil)
  56.                   )
  57.   (name nil :type symbol :read-only t)
  58.   (string "" :type stringable :read-only t)
  59.   (value nil)
  60.   (tight nil :type list) ;; List of resource-database
  61.   (loose nil :type list) ;; List of resource-database
  62.   )
  63.  
  64. ;; The value slot of the top-level resource-database structure is used for a time-stamp.
  65.  
  66. (defun make-resource-database ()
  67.   ;; Make a resource-database with initial timestamp of 0
  68.   (make-resource-database-internal :name :top-level :string "Top-Level" :value 0))
  69.  
  70. (proclaim '(inline resource-database-timestamp))
  71. (defun resource-database-timestamp (database)
  72.   (declare (type resource-database database))
  73.   (resource-database-value database))
  74.  
  75. (defun incf-resource-database-timestamp (database)
  76.   ;; Increment the timestamp
  77.   (declare (type resource-database database))
  78.   (let ((timestamp (resource-database-value database)))
  79.     (setf (resource-database-value database)
  80.       (if (= timestamp most-positive-fixnum)
  81.           most-negative-fixnum
  82.         (1+ timestamp)))))
  83.  
  84. ;; Without this, resources take forever to print...
  85. (defun print-resource (database stream depth)
  86.   (declare (type resource-database database))
  87.   (declare (ignore depth))
  88.   (princ "#<Resource " stream)
  89.   (princ (resource-database-name database))
  90.   (when (resource-database-value database)
  91.     (princ " " stream)
  92.     (prin1 (resource-database-value database)))
  93.   (princ ">"))
  94.  
  95. ;; DEBUG FUNCTION  (not exported)
  96. (defun print-db (entry &optional (level 0) type)
  97.   ;; Debug function to print a resource database
  98.   (format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]"
  99.       level
  100.       (resource-database-name entry)
  101.       (eq type 'loose)
  102.       (resource-database-value entry))
  103.   (when (resource-database-tight entry)
  104.     (dolist (tight (resource-database-tight entry))
  105.       (print-db tight (+ 2 level) 'tight)))
  106.   (when (resource-database-loose entry)
  107.     (dolist (loose (resource-database-loose entry))
  108.       (print-db loose (+ 2 level) 'loose))))
  109.  
  110. ;; DEBUG FUNCTION
  111. #+comment
  112. (defun print-search-table (table)
  113.   (terpri)
  114.   (dolist (dbase-list table)
  115.     (format t "~%~s" dbase-list)
  116.     (dolist (db dbase-list)
  117.       (print-db db)
  118.       (dolist (dblist table)
  119.     (unless (eq dblist dbase-list)
  120.       (when (member db dblist)
  121.         (format t "  duplicate at ~s" db))))
  122.       )))
  123.  
  124. (proclaim '(inline resource-key))
  125. (defun resource-key (stringable)
  126.   ;; Ensure STRINGABLE is a keyword.
  127.   (declare (type stringable stringable))
  128.   (if (keywordp stringable)
  129.       (the keyword stringable)
  130.     (resource-key-internal stringable)))
  131.  
  132. (defun resource-key-internal (stringable)
  133.   ;; Ensure STRINGABLE is a keyword.
  134.   (declare (type stringable stringable))
  135.   (if (symbolp stringable)
  136.       (kintern stringable)
  137.     (kintern (string-upcase (the string stringable)))))
  138.  
  139. ;; This is in the inner-loop of the resource search.
  140. ;; Try to be as fast as possible.
  141. (proclaim '(inline stringable-equal))
  142. (defun stringable-equal (a b)
  143.   ;; Compare two stringables.
  144.   ;; Ignore case when comparing to a symbol.
  145.   (declare (type stringable a b))
  146.   (declare-values boolean)
  147.   (macrolet (#+(or ti lmi) ;; Over twice as fast as common-lisp string-equal
  148.          (string-equal (a b)
  149.            `(si:%string-equal ,a 0 ,b 0 nil)))
  150.     (if (symbolp a)
  151.     (if (symbolp b)
  152.         (equal (the string (symbol-name a)) (the string (symbol-name b)))
  153.       (string-equal (the string (symbol-name a)) (the string b)))
  154.       (if (symbolp b)
  155.       (string-equal (the string a) (the string (symbol-name b)))
  156.     #+lispm (equal a b) ;; EQUAL is microcoded on lispm's
  157.     #-lispm (string= (the string a) (the string b))))))
  158.  
  159.  
  160. ;;;-----------------------------------------------------------------------------
  161. ;;; Add/delete resource
  162.  
  163. (defun add-resource (database name-list value)
  164.   ;; name-list is a list of either strings or symbols. If a symbol, 
  165.   ;; case-insensitive comparisons will be used, if a string,
  166.   ;; case-sensitive comparisons will be used.  The symbol '* or
  167.   ;; string "*" are used as wildcards, matching anything or nothing.
  168.   (declare (type resource-database database)
  169.        (type list name-list) ;; (list stringable)
  170.        (type t value))
  171.   (unless value (error "Null resource values are ignored"))
  172.   (incf-resource-database-timestamp database)
  173.   (do* ((list name-list (cdr list))
  174.     (string (car list) (car list))
  175.     (node database)
  176.     (loose-p nil))
  177.        ((endp list)
  178.     (setf (resource-database-value node) value))
  179.     ;; Key is the first name that isn't *
  180.     (if (or (equal string "*") (eq string '*))
  181.     (setq loose-p t)
  182.       ;; find the entry associated with name
  183.       (progn
  184.     (do ((entry (if loose-p
  185.             (resource-database-loose node)
  186.               (resource-database-tight node))
  187.             (cdr entry))
  188.          ;; Terminal names are ALWAYS in the keyword package
  189.          (name (resource-key string)))
  190.         ((endp entry)
  191.          ;; Entry not found - create a new one
  192.          (setq entry (make-resource-database-internal :name name :string string))
  193.          (if loose-p
  194.          (push entry (resource-database-loose node))
  195.            (push entry (resource-database-tight node)))
  196.          (setq node entry))
  197.       (when (stringable-equal string (resource-database-string (car entry)))
  198.         ;; Found entry - use it
  199.         (return (setq node (car entry)))))
  200.     (setq loose-p nil)))))
  201.  
  202.  
  203. (defun delete-resource (database name-list)
  204.   (declare (type resource-database database)
  205.        (type list name-list))
  206.   (incf-resource-database-timestamp database)
  207.   (delete-resource-internal database name-list))
  208.  
  209. (defun delete-resource-internal (database name-list)
  210.   (declare (type resource-database database)
  211.        (type list name-list)) ;; (list stringable)
  212.   (do* ((list name-list (cdr list))
  213.     (string (car list) (car list))
  214.     (node database)
  215.     (loose-p nil))
  216.        ((endp list) nil)
  217.     ;; Key is the first name that isn't *
  218.     (if (or (equal string "*") (eq string '*))
  219.     (setq loose-p t)
  220.       ;; find the entry associated with name
  221.       (progn 
  222.     (do* ((first-entry (if loose-p
  223.                    (resource-database-loose node)
  224.                  (resource-database-tight node)))
  225.           (entry-list first-entry (cdr entry-list))
  226.           (entry (car entry-list) (car entry-list)))
  227.          ((endp entry-list)
  228.           ;; Entry not found - exit
  229.           (return-from delete-resource-internal nil))
  230.       (when (stringable-equal string (resource-database-string entry))
  231.         (when (cdr list) (delete-resource-internal entry (cdr list)))
  232.         (when (and (null (resource-database-loose entry))
  233.                (null (resource-database-tight entry)))
  234.           (if loose-p
  235.           (setf (resource-database-loose node)
  236.             (delete entry (resource-database-loose node) :test #'eq :count 1))
  237.         (setf (resource-database-tight node)
  238.               (delete entry (resource-database-tight node) :test #'eq :count 1))))
  239.         (return-from delete-resource-internal t)))
  240.     (setq loose-p nil)))))
  241.  
  242. ;;;-----------------------------------------------------------------------------
  243. ;;; Get Resource
  244.  
  245. (defun get-resource (database value-name value-class full-name full-class)
  246.   ;; Return the value of the resource in DATABASE whose partial name
  247.   ;; most closely matches (append full-name (list value-name)) and
  248.   ;;                      (append full-class (list value-class)).
  249.   (declare (type resource-database database)
  250.        (type stringable value-name value-class)
  251.        (type list full-name full-class)) ;; (list stringable)
  252.   (declare-values value)
  253.   (let ((names (append full-name (list (resource-key value-name))))
  254.     (classes (append full-class (list (resource-key value-class)))))
  255.     (let* ((result (get-entry (resource-database-tight database) (resource-database-loose database)
  256.                   names classes)))
  257.       (when result
  258.     (resource-database-value result)))))
  259.  
  260. (defun get-entry-lookup (table name names classes)
  261.   (declare (type list table names classes)
  262.        (symbol name))
  263.   (declare (inline get-entry-lookup))
  264.   (dolist (entry table)
  265.     (declare (type resource-database entry))
  266.     (when (stringable-equal name (resource-database-name entry))
  267.       (if (null (cdr names))
  268.       (return entry)
  269.     (let ((result (get-entry (resource-database-tight entry) (resource-database-loose entry)
  270.                  (cdr names) (cdr classes))))
  271.       (declare (type (or null resource-database) result))
  272.       (when result
  273.         (return result)
  274.         ))))))
  275.  
  276. (defun get-entry (tight loose names classes &aux result)
  277.   (declare (type list tight loose names classes))
  278. ;;  (DECLARE (inline get-entry-lookup))
  279.   (declare (inline resource-key))
  280.   (let ((name (car names))
  281.     (class (car classes)))
  282.     (declare (type symbol name class))
  283.     (cond ((and tight
  284.         (get-entry-lookup tight name names classes)))
  285.       ((and loose
  286.         (get-entry-lookup loose name names classes)))
  287.       ((and tight
  288.         (not (equal name class))
  289.         (get-entry-lookup tight class names classes)))
  290.       ((and loose
  291.         (not (equal name class))
  292.         (get-entry-lookup loose class names classes)))
  293.       #+clue ;; for CLUE only
  294.       ((and *resource-subclassp*
  295.         (or loose tight)
  296.         (dolist (class (cluei::class-all-superclasses class))
  297.           (when tight
  298.             (when (setq result (get-entry-lookup tight class names classes))
  299.               (return result)))
  300.           (when loose
  301.             (when (setq result (get-entry-lookup loose class names classes))
  302.               (return result))))))    
  303.       (loose
  304.        (loop
  305.          (pop names) (pop classes)
  306.          (unless (and names classes) (return nil))
  307.          (setq name (car names)
  308.            class (car classes))
  309.          (when (setq result (get-entry-lookup loose name names classes))
  310.            (return result))
  311.          (when (and (not (equal name class))
  312.             (setq result (get-entry-lookup loose class names classes)))
  313.            (return result))
  314.          #+clue ;; for CLUE only
  315.          (when *resource-subclassp*
  316.            (dolist (class (cluei::class-all-superclasses class))
  317.          (when (setq result (get-entry-lookup loose class names classes))
  318.            (return-from get-entry result))))
  319.          )))))
  320.  
  321.  
  322. ;;;-----------------------------------------------------------------------------
  323. ;;; Get-resource with search-table
  324.  
  325. (defun get-search-resource (table name class)
  326.   ;; (get-search-resource (get-search-table database full-name full-class) value-name value-class)
  327.   ;; is equivalent to 
  328.   ;; (get-resource database value-name value-class full-name full-class)
  329.   ;; But since most of the work is done by get-search-table, get-search-resource is MUCH
  330.   ;; faster when getting several resources with the same full-name/full-class
  331.   (declare (type list table)
  332.        (type stringable name class))
  333.   (declare (inline resource-key))
  334.   (let ((name (resource-key name))
  335.     (class (and class (resource-key class))))
  336.     (declare (type stringable name class))
  337.     (block exit
  338.       (dolist (dbase-list table)
  339.     (declare (type list dbase-list))
  340.     (dolist (dbase dbase-list)
  341.       (declare (type resource-database dbase))
  342.       (when (eq name (resource-database-name dbase))
  343.         (return-from exit (resource-database-value dbase))))
  344.     (when (and class (not (eq name class)))
  345.       (dolist (dbase dbase-list)
  346.         (declare (type resource-database dbase))
  347.         (when (eq class (resource-database-name dbase))
  348.           (return-from exit (resource-database-value dbase)))))))))
  349.  
  350. (defun get-search-table (database full-name full-class)
  351.   ;; Return a search table for use with get-search-resource.
  352.   (declare (type resource-database database)
  353.        (type list full-name full-class)) ;; (list stringable)
  354.   (declare-values value)
  355.   (let* ((tight (resource-database-tight database))
  356.      (loose (resource-database-loose database))
  357.      (result (cons nil nil))
  358.      (*result* result))
  359.     (declare (type list tight loose)
  360.          (type cons result)
  361.          (special *result*))
  362.     (when (or tight loose)
  363.       (when full-name
  364.     (get-tables tight loose full-name full-class))
  365.       ;;(vector-push loose table) ;; This catches entries like: (* foreground) :white
  366.       )
  367.     (cdr result)))
  368.  
  369. (proclaim '(inline get-tables-lookup))
  370. (defun get-tables-lookup (dbase name names classes)
  371.   (declare (type list dbase names classes)
  372.        (type symbol name))
  373.   (declare (optimize speed))
  374.   (declare (special *result*))
  375.   (dolist (entry dbase)
  376.     (declare (type resource-database entry))
  377.     (when (stringable-equal name (resource-database-name entry))
  378.       (let ((tight (resource-database-tight entry))
  379.         (loose (resource-database-loose entry)))
  380.     (declare (type list tight loose))
  381.     (when (or tight loose)
  382.       (if (cdr names)
  383.           (get-tables tight loose (cdr names) (cdr classes))
  384.         (when tight
  385.           (let ((result *result*)) ;; Put tight at end of *result*
  386.         (setf (cdr result) (setq *result* (cons tight nil))))))
  387.       (when loose
  388.         (let ((result *result*)) ;; Put loose at end of *result*
  389.           (setf (cdr result) (setq *result* (cons loose nil))))))))))
  390.  
  391. (defun get-tables (tight loose names classes)
  392.   (declare (type list tight loose names classes))
  393.   (declare (inline resource-key)
  394.        (inline get-tables-lookup)
  395.        (optimize speed))
  396.   (let ((name (car names))
  397.     (class (car classes)))
  398.     (declare (type symbol name class))
  399.     (when tight
  400.       (get-tables-lookup tight name names classes))
  401.     (when loose
  402.       (get-tables-lookup loose name names classes))
  403.     (when (and tight (not (equal name class)))
  404.       (get-tables-lookup tight class names classes))
  405.     (when (and loose (not (equal name class)))
  406.       (get-tables-lookup loose class names classes))
  407.     #+clue ;; for CLUE only
  408.     (when *resource-subclassp*
  409.       (dolist (class (cluei::class-all-superclasses class))
  410.     (declare (type symbol class))
  411.     (setq class class)
  412.     (when tight
  413.       (get-tables-lookup tight class names classes))
  414.     (when loose
  415.       (get-tables-lookup loose class names classes))))
  416.     (when loose
  417.       (loop
  418.     (pop names) (pop classes)
  419.     (unless (and names classes) (return nil))
  420.     (setq name (car names)
  421.           class (car classes))
  422.     (get-tables-lookup loose name names classes)
  423.     (unless (equal name class)
  424.       (get-tables-lookup loose class names classes))
  425.     #+clue ;; for CLUE only
  426.     (when *resource-subclassp*
  427.       (dolist (class (cluei::class-all-superclasses class))
  428.         (get-tables-lookup loose class names classes)))
  429.     ))))
  430.  
  431.  
  432. ;;;-----------------------------------------------------------------------------
  433. ;;; Utility functions
  434.  
  435. (defun map-resource (database function &rest args)
  436.   ;; Call FUNCTION on each resource in DATABASE.
  437.   ;; FUNCTION is called with arguments (name-list value . args)
  438.   (declare (type resource-database database)
  439.        (type (function (list t &rest t) t) function))
  440.   (declare-values nil)
  441.   (labels ((map-resource-internal (database function args name)
  442.          (let ((tight (resource-database-tight database))
  443.            (loose (resource-database-loose database)))
  444.            (dolist (resource tight)
  445.          (let ((value (resource-database-value resource))
  446.                (name (append name (list (resource-database-name resource)))))
  447.            (if value
  448.                (apply function name value args)
  449.              (map-resource-internal resource function args name))))
  450.            (dolist (resource loose)
  451.          (let ((value (resource-database-value resource))
  452.                (name (append name (list '* (resource-database-name resource)))))
  453.            (if value
  454.                (apply function name value args)
  455.              (map-resource-internal resource function args name)))))))
  456.     (map-resource-internal database function args nil)))
  457.  
  458. (defun merge-resources (database with-database)
  459.   (declare (type resource-database database with-database))
  460.   (declare-values resource-database)
  461.   (map-resource #'add-resource database with-database)
  462.   with-database)
  463.  
  464. (defun char-memq (key char)
  465.   ;; Used as a test function for POSITION
  466.   (declare (type string-char char))
  467.   (member char key))
  468.  
  469. (eval-when (compile eval) ;; Not needed after compilation
  470. (defmacro resource-with-open-file ((stream pathname &rest options) &body body)
  471.   ;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the stream
  472.   (let ((abortp (gensym))
  473.     (streamp (gensym)))
  474.     `(let* ((,abortp t)
  475.         (,streamp (streamp pathname))
  476.         (,stream (if ,streamp pathname (open ,pathname ,@options))))
  477.        (unwind-protect
  478.        (progn
  479.          ,@body
  480.          (setq ,abortp nil))
  481.      (unless ,streamp
  482.        (close stream :abort ,abortp))))))
  483. ) ;; end eval-when
  484.  
  485. (defun read-resources (database pathname &key key test test-not)
  486.   ;; Merges resources from a file in standard X11 format with DATABASE.
  487.   ;; KEY is a function used for converting value-strings, the default is
  488.   ;; identity.  TEST and TEST-NOT are predicates used for filtering
  489.   ;; which resources to include in the database.  They are called with
  490.   ;; the name and results of the KEY function.
  491.   (declare (type resource-database database)
  492.        (type (or pathname string stream) pathname)
  493.        (type (or null (function (string) t)) key)
  494.        (type (or null (function (list t) boolean))
  495.                  test test-not))
  496.   (declare-values resource-database)
  497.   (resource-with-open-file (stream pathname)
  498.     (loop
  499.       (let ((string (read-line stream nil :eof)))
  500.     (declare (type string string))
  501.     (when (eq string :eof) (return database))
  502.     (let* ((end (length string))
  503.            (i (position '(#\tab #\space) string :test-not #'char-memq :end end))
  504.            (term nil))
  505.       (declare (type array-index end)
  506.            (type (or null array-index) i term))
  507.       (when i ;; else blank line
  508.         (case (char string i)
  509.           (#\! nil)  ;; Comment - skip
  510.           (#.(int-char 0) nil) ;; terminator for C strings - skip
  511.           (#\#       ;; Include
  512.            (setq term (position '(#\tab #\space) string :test #'char-memq
  513.                     :start i :end end))
  514.            (if (not (string-equal string "#INCLUDE" :start1 i :end1 term))
  515.            (format t "~%Resource File error. Ignoring: ~a" string)
  516.          (let ((path (merge-pathnames (subseq string (1+ term)) (truename stream))))
  517.            (read-resources database path :key key :test test :test-not test-not))))
  518.           (otherwise
  519.            (multiple-value-bind (name-list value)
  520.            (parse-resource string i end)
  521.          (when
  522.            (cond (test (funcall test name-list value))
  523.              (test-not (not (funcall test-not name-list value)))
  524.              (t t))
  525.            (when key (setq value (funcall key value)))
  526.            (add-resource database name-list value)))))))))))
  527.  
  528. (defun parse-resource (string &optional (start 0) end)
  529.   ;; Parse a resource specfication string into a list of names and a value string
  530.   (declare (type string string)
  531.        (type array-index start)
  532.        (type (or null array-index) end))
  533.   (declare-values name-list value)
  534.   (do ((i start)
  535.        (end (or end (length string)))
  536.        (term)
  537.        (name-list)
  538.        (previous))
  539.       ((>= i end))
  540.     (declare (type array-index end)
  541.          (type (or null array-index) i term))
  542.     (setq term (position '(#\. #\* #\:) string
  543.              :test #'char-memq :start i :end end))
  544.     (case (and term (char string term))
  545.       ;; Name seperator
  546.       (#\. (when (> term i)
  547.          (push (subseq string i term) name-list)))
  548.       ;; Wildcard seperator
  549.       (#\* (when (> term i)
  550.          (push (subseq string i term) name-list))
  551.        (push '* name-list))
  552.       ;; Value seperator
  553.       (#\: (push (subseq string i term) name-list)
  554.        (let* ((start (position '(#\tab #\space) string
  555.                    :test-not #'char-memq
  556.                    :start (1+ term) :end end))
  557.           (value (and (> end start) (subseq string start))))
  558.          (return (values (nreverse name-list) (string-right-trim '(#\tab #\space) value))))))
  559.     (setq previous (char string term))
  560.     (setq i (1+ term))))
  561.  
  562. (defun write-resources (database pathname &key write test test-not)
  563.   ;; Write resources to PATHNAME in the standard X11 format.
  564.   ;; WRITE is a function used for writing values, the default is #'princ
  565.   ;; TEST and TEST-NOT are predicates used for filtering which resources
  566.   ;; to include in the database.  They are called with the name and value.
  567.   (declare (type resource-database database)
  568.        (type (or pathname string stream) pathname)
  569.        (type (or null (function (string stream) t)) write)
  570.        (type (or null (function (list t) boolean))
  571.                  test test-not))
  572.   (resource-with-open-file (stream pathname :direction :output)
  573.     (map-resource
  574.       database
  575.       #'(lambda (name-list value stream write test test-not)
  576.       (when
  577.         (cond (test (funcall test name-list value))
  578.           (test-not (not (funcall test-not name-list value)))
  579.           (t t))
  580.         (let ((previous (car name-list)))
  581.           (princ previous stream)
  582.           (dolist (name (cdr name-list))
  583.         (unless (or (eq name '*) (eq previous '*))
  584.           (write-char #\. stream))
  585.         (setq previous name)
  586.         (princ name stream)))
  587.         (write-string ":    " stream)
  588.         (funcall write value stream)
  589.         (terpri stream)))
  590.       stream (or write #'princ) test test-not))
  591.   database)
  592.  
  593.  
  594. (defun wm-resources (database window &key key test test-not)
  595.   ;; Takes the resources associated with the RESOURCE_MANAGER property
  596.   ;; of WINDOW (if any) and merges them with DATABASE.
  597.   ;; KEY is a function used for converting value-strings, the default is
  598.   ;; identity.  TEST and TEST-NOT are predicates used for filtering
  599.   ;; which resources to include in the database.  They are called with
  600.   ;; the name and results of the KEY function.
  601.   (declare (type resource-database database)
  602.        (type window window)
  603.        (type (or null (function (string) t)) key)
  604.        (type (or null (function (list t) boolean))
  605.                  test test-not))
  606.   (declare-values resource-database)
  607.   (let ((string (get-property window :resource_manager :type :string
  608.                   :result-type 'string :transform #'xlib::card8->char)))
  609.     (when string
  610.       (with-input-from-string (stream string)
  611.     (read-resources database stream :key key :test test :test-not test-not)))))
  612.  
  613. (defun set-wm-resources (database window &key write test test-not)
  614.   ;; Sets the resources associated with the RESOURCE_MANAGER property
  615.   ;; of WINDOW.
  616.   ;; WRITE is a function used for writing values, the default is #'princ
  617.   ;; TEST and TEST-NOT are predicates used for filtering which resources
  618.   ;; to include in the database.  They are called with the name and value.
  619.   (declare (type resource-database database)
  620.        (type window window)
  621.        (type (or null (function (string stream) t)) write)
  622.        (type (or null (function (list t) boolean))
  623.                  test test-not))
  624.   (xlib::set-string-property
  625.     window :resource_manager
  626.     (with-output-to-string (stream)
  627.       (write-resources database stream :write write
  628.                :test test :test-not test-not))))
  629.